home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / kcl / kcl.lha / c / macros.c < prev    next >
C/C++ Source or Header  |  1987-06-04  |  7KB  |  325 lines
  1. /*
  2. (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984.  All rights reserved.
  3. Copying of this file is authorized to users who have executed the true and
  4. proper "License Agreement for Kyoto Common LISP" with SIGLISP.
  5. */
  6.  
  7. /*
  8.     macros.c
  9. */
  10.  
  11. #include "include.h"
  12.  
  13. object Vmacroexpand_hook;
  14. object siSdefmacroA;
  15.  
  16. object Swarn;
  17.  
  18. object siVinhibit_macro_special;
  19.  
  20. siLdefine_macro()
  21. {
  22.     check_arg(2);
  23.     if (type_of(vs_base[0]) != t_symbol)
  24.         not_a_symbol(vs_base[0]);
  25.     if (vs_base[0]->s.s_sfdef != NOT_SPECIAL) {
  26.         if (vs_base[0]->s.s_mflag) {
  27.             if (symbol_value(siVinhibit_macro_special) != Cnil)
  28.                 vs_base[0]->s.s_sfdef = NOT_SPECIAL;
  29.         } else if (symbol_value(siVinhibit_macro_special) != Cnil)
  30.             FEerror("~S, a special form, cannot be redefined.",
  31.                 1, vs_base[0]);
  32.     }
  33.     clear_compiler_properties(vs_base[0]);
  34.     if (vs_base[0]->s.s_hpack == lisp_package &&
  35.         vs_base[0]->s.s_gfdef != OBJNULL && initflag) {
  36.         vs_push(make_simple_string(
  37.             "~S is being redefined."));
  38.         ifuncall2(Swarn, vs_head, vs_base[0]);
  39.         vs_pop;
  40.     }
  41.     vs_base[0]->s.s_gfdef = MMcaddr(vs_base[1]);
  42.     vs_base[0]->s.s_mflag = TRUE;
  43.     if (MMcar(vs_base[1]) != Cnil) {
  44.         vs_base[0]->s.s_plist
  45.         = putf(vs_base[0]->s.s_plist,
  46.                MMcar(vs_base[1]),
  47.                siSfunction_documentation);
  48.     }
  49.     if (MMcadr(vs_base[1]) != Cnil) {
  50.         vs_base[0]->s.s_plist
  51.         = putf(vs_base[0]->s.s_plist,
  52.                MMcadr(vs_base[1]),
  53.                siSpretty_print_format);
  54.     }
  55.     vs_top = vs_base+1;
  56. }
  57.  
  58. Fdefmacro(form)
  59. object form;
  60. {
  61.     object *top = vs_top;
  62.     object name;
  63.  
  64.     if (endp(form) || endp(MMcdr(form)))
  65.         FEtoo_few_argumentsF(form);
  66.     name = MMcar(form);
  67.     if (type_of(name) != t_symbol)
  68.         not_a_symbol(name);
  69.     vs_push(ifuncall3(siSdefmacroA,
  70.               name,
  71.               MMcadr(form),
  72.               MMcddr(form)));
  73.     if (MMcar(top[0]) != Cnil)
  74.         name->s.s_plist
  75.         = putf(name->s.s_plist,
  76.                MMcar(top[0]),
  77.                siSfunction_documentation);
  78.     if (MMcadr(top[0]) != Cnil)
  79.         name->s.s_plist
  80.         = putf(name->s.s_plist,
  81.                MMcadr(top[0]),
  82.                siSpretty_print_format);
  83.     if (name->s.s_sfdef != NOT_SPECIAL) {
  84.         if (name->s.s_mflag) {
  85.             if (symbol_value(siVinhibit_macro_special) != Cnil)
  86.                 name->s.s_sfdef = NOT_SPECIAL;
  87.         } else if (symbol_value(siVinhibit_macro_special) != Cnil)
  88.             FEerror("~S, a special form, cannot be redefined.",
  89.                 1, name);
  90.     }
  91.     clear_compiler_properties(name);
  92.     if (name->s.s_hpack == lisp_package &&
  93.         name->s.s_gfdef != OBJNULL && initflag) {
  94.         vs_push(make_simple_string(
  95.             "~S is being redefined."));
  96.         ifuncall2(Swarn, vs_head, name);
  97.         vs_pop;
  98.     }
  99.     name->s.s_gfdef = MMcaddr(top[0]);
  100.     name->s.s_mflag = TRUE;
  101.     vs_base = vs_top = top;
  102.     vs_push(name);
  103. }
  104.  
  105. /*
  106.     MACRO_EXPAND1 is an internal function which simply applies the
  107.     function EXP_FUN to FORM.  On return, the expanded form is stored
  108.     in VS_BASE[0].
  109. */
  110. macro_expand1(exp_fun, form)
  111. object exp_fun,form;
  112. {
  113.     vs_base = vs_top;
  114.     vs_push(exp_fun);
  115.     vs_push(form);
  116. /***/
  117.     vs_push(Cnil);
  118. /***/
  119.     super_funcall(symbol_value(Vmacroexpand_hook));
  120.     if (vs_top == vs_base)
  121.         vs_push(Cnil);
  122. }
  123.  
  124. /*
  125.     MACRO_DEF is an internal function which, given a form, returns
  126.     the expansion function if the form is a macro form.  Otherwise,
  127.     MACRO_DEF returns NIL.
  128. */
  129. object
  130. macro_def(form)
  131. object form;
  132. {
  133.     object head, fd;
  134.  
  135.     if (type_of(form) != t_cons)
  136.         return(Cnil);
  137.     head = MMcar(form);
  138.     if (type_of(head) != t_symbol)
  139.         return(Cnil);
  140.     fd = lex_fd_sch(head);
  141.     if (MMnull(fd))
  142.         if (head->s.s_mflag)
  143.             return(head->s.s_gfdef);
  144.         else
  145.             return(Cnil);
  146.     else if (MMcadr(fd) == Smacro)
  147.         return(MMcaddr(fd));
  148.     else
  149.         return(Cnil);
  150. }
  151.  
  152. Lmacroexpand()
  153. {
  154.     object exp_fun, env;
  155.     object *base = vs_base;
  156.     object *lex=lex_env;
  157.  
  158.     lex_env = vs_top;
  159.     if (vs_top-vs_base < 1)
  160.         too_few_arguments();
  161.     else if (vs_top-vs_base == 1) {
  162.         vs_top[0] = vs_top[1] = vs_top[2] = Cnil;
  163.         vs_top += 3;
  164.     } else if (vs_top - vs_base == 2) {
  165.         env = vs_base[1];
  166.         vs_push(car(env));
  167.         env = cdr(env);
  168.         vs_push(car(env));
  169.         env = cdr(env);
  170.         vs_push(car(env));
  171.     } else
  172.         too_many_arguments();
  173.     exp_fun = macro_def(base[0]);
  174.     if (MMnull(exp_fun)) {
  175.         lex_env = lex;
  176.         vs_base = base;
  177.         vs_top = base + 1;
  178.         vs_push(Cnil);
  179.     } else {
  180.         object *top = vs_top;
  181.  
  182.         do {
  183.             macro_expand1(exp_fun, base[0]);
  184.             base[0] = vs_base[0];
  185.             vs_top = top;
  186.             exp_fun = macro_def(base[0]);
  187.         } while (!MMnull(exp_fun));
  188.         lex_env = lex;
  189.         vs_base = base;
  190.         vs_top = base+1;
  191.         vs_push(Ct);
  192.     }
  193. }
  194.  
  195. Lmacroexpand_1()
  196. {
  197.     object exp_fun;
  198.     object *base=vs_base;
  199.     object *lex=lex_env;
  200.  
  201.     lex_env = vs_top;
  202.     if (vs_top-vs_base<1)
  203.         too_few_arguments();
  204.     else if (vs_top-vs_base == 1) {
  205.         vs_push(Cnil);
  206.         vs_push(Cnil);
  207.         vs_push(Cnil);
  208.     } else if (vs_top-vs_base == 2) {
  209.         vs_push(car(vs_base[1]));
  210.         vs_push(car(cdr(vs_base[1])));
  211.         vs_push(car(cdr(cdr(vs_base[1]))));
  212.     } else
  213.         too_many_arguments();
  214.     exp_fun = macro_def(base[0]);
  215.     if (MMnull(exp_fun)) {
  216.         lex_env = lex;
  217.         vs_base = base;
  218.         vs_top = base+1;
  219.         vs_push(Cnil);
  220.     } else {
  221.         macro_expand1(exp_fun, base[0]);
  222.         base[0] = vs_base[0];
  223.         lex_env = lex;
  224.         vs_base = base;
  225.         vs_top = base+1;
  226.         vs_push(Ct);
  227.     }
  228. }
  229.  
  230. /*
  231.     MACRO_EXPAND is an internal function which, given a form, expands it
  232.     as many times as possible and returns the finally expanded form.
  233.     The argument 'form' need not be marked for GBC and the result is not
  234.     marked.
  235. */
  236. object
  237. macro_expand(form)
  238. object form;
  239. {
  240.     object exp_fun, head, fd;
  241.     object *base = vs_base;
  242.     object *top = vs_top;
  243.  
  244.     /* Check if the given form is a macro form.  If not, return
  245.        immediately.  Macro definitions are superseded by special-
  246.        form definitions.
  247.     */
  248.     if (type_of(form) != t_cons)
  249.         return(form);
  250.     head = MMcar(form);
  251.     if (type_of(head) != t_symbol)
  252.         return(form);
  253.     if (head->s.s_sfdef != NOT_SPECIAL)
  254.         return(form);
  255.     fd = lex_fd_sch(head);
  256.     if (MMnull(fd))
  257.         if (head->s.s_mflag)
  258.             exp_fun = head->s.s_gfdef;
  259.         else
  260.             return(form);
  261.     else if (MMcadr(fd) == Smacro)
  262.         exp_fun = MMcaddr(fd);
  263.     else
  264.         return(form);
  265.     
  266.     vs_top = top;
  267.     vs_push(form);            /* saves form in top[0] */
  268.     vs_push(exp_fun);        /* saves exp_fun in top[1] */
  269. LOOP:
  270.     /*  macro_expand1(exp_fun, form);  */
  271.     vs_base = vs_top;
  272.     vs_push(exp_fun);
  273.     vs_push(form);
  274. /***/
  275.     vs_push(Cnil);
  276. /***/
  277.     super_funcall(symbol_value(Vmacroexpand_hook));
  278.     if (vs_base == vs_top)
  279.         vs_push(Cnil);
  280.     top[0] = form = vs_base[0];
  281.     /* Check if the expanded form is again a macro form.  If not,
  282.        reset the stack and return.
  283.     */
  284.     if (type_of(form) != t_cons)
  285.         goto END;
  286.     head = MMcar(form);
  287.     if (type_of(head) != t_symbol)
  288.         goto END;
  289.     if (head->s.s_sfdef != NOT_SPECIAL)
  290.         goto END;
  291.     fd=lex_fd_sch(head);
  292.     if (MMnull(fd))
  293.         if (head->s.s_mflag)
  294.             exp_fun = head->s.s_gfdef;
  295.         else
  296.             goto END;
  297.     else if (MMcadr(fd) == Smacro)
  298.         exp_fun = MMcaddr(fd);
  299.     else
  300.         goto END;
  301.     /* The expanded form is a macro form.  Continue expansion.  */
  302.     top[1] = exp_fun;
  303.     vs_top = top + 2;
  304.     goto LOOP;
  305. END:
  306.     vs_base = base;
  307.     vs_top = top;
  308.     return(form);
  309. }
  310.  
  311. init_macros()
  312. {
  313.     make_si_function("DEFINE-MACRO", siLdefine_macro);
  314.     Vmacroexpand_hook
  315.     = make_special("*MACROEXPAND-HOOK*", Sfuncall);
  316.     make_function("MACROEXPAND", Lmacroexpand);
  317.     make_function("MACROEXPAND-1", Lmacroexpand_1);
  318.     make_special_form("DEFMACRO", Fdefmacro);
  319.     siSdefmacroA = make_si_ordinary("DEFMACRO*");
  320.     enter_mark_origin(&siSdefmacroA);
  321.  
  322.     siVinhibit_macro_special =
  323.     make_si_special("*INHIBIT-MACRO-SPECIAL*", Cnil);
  324. }
  325.